Shareware Grab Bag/Shareware Grab Bag.iso/003/header.arc/HEADER.PAS

Pascal/Delphi Source File | 1986-05-16 | 5.5 KB | 177 lines

program header;
{$c-}

{ Copyright (c) 1986 Proud Products Inc }

{ Filename...............header.pas }
{ Program................Read dBASE III Header v1.0 }
{ Date started...........05/08/86 }
{ Last update............05/13/86 }
{ Language...............TURBO PASCAL 3.0 }
{ Programmer.............Douglas Apperley }


type
  fields                                     = string[11];
  char80                                     = string[80];
  cmdstring                                  = string[127];

var
  field_type,terminator,version_number         : char;
  total_records                                : real;
  tlhs,number_of_fields,length_of_record       : integer;
  field_len,field_dec,i,j                      : integer;
  ok1                                          : boolean;
  cmdbuffer                                    : cmdstring;
  last_up_date1,last_up_date2,last_up_date3    : string[3];
  field_names                                  : string[11];
  input_file,ftype                             : string[15];
  work_field                                   : string[32];
  work_hold                                    : string[31];
  dbf_file                                     : text[$800];
  text_file                                    : text[$800];
  number_of_records                            : array[1..4] of char;
  hold,header                                  : array[1..2000] of char;
  cmdline                                      : cmdstring absolute cseg:$80;

const
  blanks='                                    ';


{ lhs  =  length of the header structure }
{ tlhs =  total length of the header structure }


procedure initialize;
begin
  textbackground(black);
  textcolor(white);
  j:=1;
  for i:=1 to 200 do
    header[i]:=' ';
  cmdbuffer:=cmdline;
  if paramcount<>1 then
  begin
    writeln;
    writeln('One parameter expected');
    writeln;
    writeln('This program will display the structure of a dBASE III (r) file,');
    writeln('that is passed as a parameter.  A file with the same name and an');
    writeln('extension of STR will be created.  This is a text file containing');
    writeln('the DBF file structure.');
    halt;
  end;
  input_file:=paramstr(1);
end;


procedure open_files;
begin
  assign(dbf_file,input_file);
  if pos('.',input_file)=0 then
    assign(dbf_file,input_file+'.DBF');
  {$I-} reset(dbf_file) {I$+};
  ok1:=(ioresult=0);
  if not ok1 then
  begin
    writeln;
    writeln('File not found');
    halt;
  end;
  assign(text_file,input_file+'.STR');
  if pos('.',input_file)>0 then
    assign(text_file,copy(input_file,1,pos('.',input_file))+'STR');
  rewrite(text_file);
end;


procedure close_files;
begin
  close(dbf_file);
  close(text_file);
end;


procedure read_header;
begin
  for i:=1 to 32 do
    read(dbf_file,header[i]);
  version_number:=header[1];
  last_up_date1:=header[2];
  last_up_date2:=header[3];
  last_up_date3:=header[4];
  for i:=1 to 4 do
    number_of_records[i]:=header[i+4];
  total_records:=ord(number_of_records[1])+ord(number_of_records[2])*256;
  total_records:=total_records+ord(number_of_records[3])*512+ord(number_of_records[4])*768;
  tlhs:=ord(header[9])+ord(header[10])*128;
  length_of_record:=ord(header[11])+ord(header[12])*256;
  writeln;
  writeln(text_file);
  writeln('Data Based Advisor Magazine');
  writeln('1975 5th Ave #105');
  writeln('San Diego, CA 92101');
  writeln('[phone]');
  writeln;
  writeln('Structure for database   : ',input_file);
  writeln(text_file,'Structure for database   : ',input_file);
  writeln('Number of data records   : ',total_records:6:0);
  writeln(text_file,'Number of data records   : ',total_records:6:0);
  writeln('Date of last update      : ',ord(last_up_date2),'/',ord(last_up_date3),'/',ord(last_up_date1));
  writeln(text_file,'Date of last update      : ',ord(last_up_date2),'/',ord(last_up_date3),'/',ord(last_up_date1));
  writeln('Field  Field name  Type         Width    Dec');
  writeln(text_file,'Field  Field name  Type         Width    Dec');
  read(dbf_file,terminator);
  while (ord(terminator)<>13) do
  begin
    for i:=1 to 31 do
      read(dbf_file,header[i]);
    work_hold:='';
    work_field:='';
    for i:=1 to 32 do
      work_hold:=work_hold+header[i];
    work_field:=terminator+work_hold;
    field_names:=copy(work_field,1,11);
    field_type:=copy(work_field,12,1);
    if field_type='M' then
      field_len:=10
    else
      field_len:=ord(copy(work_field,17,1));
    field_dec:=ord(copy(work_field,18,1));
    write(j:5,'  ',field_names,' ');
    write(text_file,j:5,'  ',field_names,' ');
    j:=j+1;
    case field_type of
      'C' : ftype:='Character';
      'N' : ftype:='Numeric';
      'L' : ftype:='Logical';
      'D' : ftype:='Date';
      'M' : ftype:='Memo';
    end;
    if field_dec=0 then
    begin
      writeln(ftype,copy(blanks,1,15-length(ftype)),field_len:3);
      writeln(text_file,ftype,copy(blanks,1,15-length(ftype)),field_len:3);
    end
    else
    begin
      writeln(ftype,copy(blanks,1,15-length(ftype)),field_len:3,'     ',field_dec:2);
      writeln(text_file,ftype,copy(blanks,1,15-length(ftype)),field_len:3,'     ',field_dec:2);
    end;
    read(dbf_file,terminator);
  end;
writeln('** Total **                      ',length_of_record:4);
writeln(text_file,'** Total **                      ',length_of_record:4);
end;


{main line}

begin
  initialize;
  open_files;
  read_header;
  close_files;
end.
{eof}